home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libcruft / lapack / dlamc4.f < prev    next >
Text File  |  1996-07-19  |  2KB  |  85 lines
  1. *
  2. ************************************************************************
  3. *
  4.       SUBROUTINE DLAMC4( EMIN, START, BASE )
  5. *
  6. *  -- LAPACK auxiliary routine (version 2.0) --
  7. *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
  8. *     Courant Institute, Argonne National Lab, and Rice University
  9. *     October 31, 1992
  10. *
  11. *     .. Scalar Arguments ..
  12.       INTEGER            BASE, EMIN
  13.       DOUBLE PRECISION   START
  14. *     ..
  15. *
  16. *  Purpose
  17. *  =======
  18. *
  19. *  DLAMC4 is a service routine for DLAMC2.
  20. *
  21. *  Arguments
  22. *  =========
  23. *
  24. *  EMIN    (output) EMIN
  25. *          The minimum exponent before (gradual) underflow, computed by
  26. *          setting A = START and dividing by BASE until the previous A
  27. *          can not be recovered.
  28. *
  29. *  START   (input) DOUBLE PRECISION
  30. *          The starting point for determining EMIN.
  31. *
  32. *  BASE    (input) INTEGER
  33. *          The base of the machine.
  34. *
  35. * =====================================================================
  36. *
  37. *     .. Local Scalars ..
  38.       INTEGER            I
  39.       DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
  40. *     ..
  41. *     .. External Functions ..
  42.       DOUBLE PRECISION   DLAMC3
  43.       EXTERNAL           DLAMC3
  44. *     ..
  45. *     .. Executable Statements ..
  46. *
  47.       A = START
  48.       ONE = 1
  49.       RBASE = ONE / BASE
  50.       ZERO = 0
  51.       EMIN = 1
  52.       B1 = DLAMC3( A*RBASE, ZERO )
  53.       C1 = A
  54.       C2 = A
  55.       D1 = A
  56.       D2 = A
  57. *+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
  58. *    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
  59.    10 CONTINUE
  60.       IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
  61.      $    ( D2.EQ.A ) ) THEN
  62.          EMIN = EMIN - 1
  63.          A = B1
  64.          B1 = DLAMC3( A / BASE, ZERO )
  65.          C1 = DLAMC3( B1*BASE, ZERO )
  66.          D1 = ZERO
  67.          DO 20 I = 1, BASE
  68.             D1 = D1 + B1
  69.    20    CONTINUE
  70.          B2 = DLAMC3( A*RBASE, ZERO )
  71.          C2 = DLAMC3( B2 / RBASE, ZERO )
  72.          D2 = ZERO
  73.          DO 30 I = 1, BASE
  74.             D2 = D2 + B2
  75.    30    CONTINUE
  76.          GO TO 10
  77.       END IF
  78. *+    END WHILE
  79. *
  80.       RETURN
  81. *
  82. *     End of DLAMC4
  83. *
  84.       END
  85.